Partie I

Liste des packages nécessaires.

library(readr)
library(tidyverse)
library(readxl)
library(FactoMineR)
library(factoextra)
library(arsenal)
library(knitr)
library(dplyr)
library(ggplot2)
library(clean)
library(gtsummary)
library(clValid)
library(mclust)
library(ggpubr)
source(url("https://raw.githubusercontent.com/larmarange/JLutils/master/R/clustering.R"))
library(reshape2)

Téléchargement de notre dataset pour lequel nous avons renommé les noms des colonnes.

data <- read_csv("wdbc.data", 
                 col_names = c("ID number",
                               "Diagnosis",
                               "radius_mean",
                               "texture_mean",
                               "perimeter_mean",
                               "area_mean","smoothness_mean",
                               "compactness_mean",
                               "concavity_mean",
                               "concave_points_mean",
                               "symmetry_mean",
                               "fractal_dimension_mean",
                               "radius_SE","texture_SE",
                               "perimeter_SE","area_SE",
                               "smoothness_SE",
                               "compactness_SE",
                               "concavity_SE",
                               "concave_points_SE",
                               "symmetry_SE",
                               "fractal_dimension_SE",
                               "radius_worst",
                               "texture_worst",
                               "perimeter_worst",
                               "area_worst",
                               "smoothness_worst",
                               "compactness_worst",
                               "concavity_worst",
                               "concave_points_worst",
                               "symmetry_worst",
                               "fractal_dimension_worst"))

clean_data <- data %>% 
  select(c(contains("_mean"), Diagnosis)) %>% 
  drop_na()

Question n°1

Tout d’abord voici ci-dessous les différentes variables de notre dataset.

glimpse(data)
## Rows: 569
## Columns: 32
## $ `ID number`             <dbl> 842302, 842517, 84300903, 84348301, 84358402, …
## $ Diagnosis               <chr> "M", "M", "M", "M", "M", "M", "M", "M", "M", "…
## $ radius_mean             <dbl> 17.990, 20.570, 19.690, 11.420, 20.290, 12.450…
## $ texture_mean            <dbl> 10.38, 17.77, 21.25, 20.38, 14.34, 15.70, 19.9…
## $ perimeter_mean          <dbl> 122.80, 132.90, 130.00, 77.58, 135.10, 82.57, …
## $ area_mean               <dbl> 1001.0, 1326.0, 1203.0, 386.1, 1297.0, 477.1, …
## $ smoothness_mean         <dbl> 0.11840, 0.08474, 0.10960, 0.14250, 0.10030, 0…
## $ compactness_mean        <dbl> 0.27760, 0.07864, 0.15990, 0.28390, 0.13280, 0…
## $ concavity_mean          <dbl> 0.30010, 0.08690, 0.19740, 0.24140, 0.19800, 0…
## $ concave_points_mean     <dbl> 0.14710, 0.07017, 0.12790, 0.10520, 0.10430, 0…
## $ symmetry_mean           <dbl> 0.2419, 0.1812, 0.2069, 0.2597, 0.1809, 0.2087…
## $ fractal_dimension_mean  <dbl> 0.07871, 0.05667, 0.05999, 0.09744, 0.05883, 0…
## $ radius_SE               <dbl> 1.0950, 0.5435, 0.7456, 0.4956, 0.7572, 0.3345…
## $ texture_SE              <dbl> 0.9053, 0.7339, 0.7869, 1.1560, 0.7813, 0.8902…
## $ perimeter_SE            <dbl> 8.589, 3.398, 4.585, 3.445, 5.438, 2.217, 3.18…
## $ area_SE                 <dbl> 153.40, 74.08, 94.03, 27.23, 94.44, 27.19, 53.…
## $ smoothness_SE           <dbl> 0.006399, 0.005225, 0.006150, 0.009110, 0.0114…
## $ compactness_SE          <dbl> 0.049040, 0.013080, 0.040060, 0.074580, 0.0246…
## $ concavity_SE            <dbl> 0.05373, 0.01860, 0.03832, 0.05661, 0.05688, 0…
## $ concave_points_SE       <dbl> 0.015870, 0.013400, 0.020580, 0.018670, 0.0188…
## $ symmetry_SE             <dbl> 0.03003, 0.01389, 0.02250, 0.05963, 0.01756, 0…
## $ fractal_dimension_SE    <dbl> 0.006193, 0.003532, 0.004571, 0.009208, 0.0051…
## $ radius_worst            <dbl> 25.38, 24.99, 23.57, 14.91, 22.54, 15.47, 22.8…
## $ texture_worst           <dbl> 17.33, 23.41, 25.53, 26.50, 16.67, 23.75, 27.6…
## $ perimeter_worst         <dbl> 184.60, 158.80, 152.50, 98.87, 152.20, 103.40,…
## $ area_worst              <dbl> 2019.0, 1956.0, 1709.0, 567.7, 1575.0, 741.6, …
## $ smoothness_worst        <dbl> 0.1622, 0.1238, 0.1444, 0.2098, 0.1374, 0.1791…
## $ compactness_worst       <dbl> 0.6656, 0.1866, 0.4245, 0.8663, 0.2050, 0.5249…
## $ concavity_worst         <dbl> 0.71190, 0.24160, 0.45040, 0.68690, 0.40000, 0…
## $ concave_points_worst    <dbl> 0.26540, 0.18600, 0.24300, 0.25750, 0.16250, 0…
## $ symmetry_worst          <dbl> 0.4601, 0.2750, 0.3613, 0.6638, 0.2364, 0.3985…
## $ fractal_dimension_worst <dbl> 0.11890, 0.08902, 0.08758, 0.17300, 0.07678, 0…

Voici ci-dessous une petit test statistique sur les variables que nous allons étudier.

data$Diagnosis <- as.factor(data$Diagnosis)
summary(data)
##    ID number         Diagnosis  radius_mean      texture_mean  
##  Min.   :     8670   B:357     Min.   : 6.981   Min.   : 9.71  
##  1st Qu.:   869218   M:212     1st Qu.:11.700   1st Qu.:16.17  
##  Median :   906024             Median :13.370   Median :18.84  
##  Mean   : 30371831             Mean   :14.127   Mean   :19.29  
##  3rd Qu.:  8813129             3rd Qu.:15.780   3rd Qu.:21.80  
##  Max.   :911320502             Max.   :28.110   Max.   :39.28  
##  perimeter_mean     area_mean      smoothness_mean   compactness_mean 
##  Min.   : 43.79   Min.   : 143.5   Min.   :0.05263   Min.   :0.01938  
##  1st Qu.: 75.17   1st Qu.: 420.3   1st Qu.:0.08637   1st Qu.:0.06492  
##  Median : 86.24   Median : 551.1   Median :0.09587   Median :0.09263  
##  Mean   : 91.97   Mean   : 654.9   Mean   :0.09636   Mean   :0.10434  
##  3rd Qu.:104.10   3rd Qu.: 782.7   3rd Qu.:0.10530   3rd Qu.:0.13040  
##  Max.   :188.50   Max.   :2501.0   Max.   :0.16340   Max.   :0.34540  
##  concavity_mean    concave_points_mean symmetry_mean    fractal_dimension_mean
##  Min.   :0.00000   Min.   :0.00000     Min.   :0.1060   Min.   :0.04996       
##  1st Qu.:0.02956   1st Qu.:0.02031     1st Qu.:0.1619   1st Qu.:0.05770       
##  Median :0.06154   Median :0.03350     Median :0.1792   Median :0.06154       
##  Mean   :0.08880   Mean   :0.04892     Mean   :0.1812   Mean   :0.06280       
##  3rd Qu.:0.13070   3rd Qu.:0.07400     3rd Qu.:0.1957   3rd Qu.:0.06612       
##  Max.   :0.42680   Max.   :0.20120     Max.   :0.3040   Max.   :0.09744       
##    radius_SE        texture_SE      perimeter_SE       area_SE       
##  Min.   :0.1115   Min.   :0.3602   Min.   : 0.757   Min.   :  6.802  
##  1st Qu.:0.2324   1st Qu.:0.8339   1st Qu.: 1.606   1st Qu.: 17.850  
##  Median :0.3242   Median :1.1080   Median : 2.287   Median : 24.530  
##  Mean   :0.4052   Mean   :1.2169   Mean   : 2.866   Mean   : 40.337  
##  3rd Qu.:0.4789   3rd Qu.:1.4740   3rd Qu.: 3.357   3rd Qu.: 45.190  
##  Max.   :2.8730   Max.   :4.8850   Max.   :21.980   Max.   :542.200  
##  smoothness_SE      compactness_SE      concavity_SE     concave_points_SE 
##  Min.   :0.001713   Min.   :0.002252   Min.   :0.00000   Min.   :0.000000  
##  1st Qu.:0.005169   1st Qu.:0.013080   1st Qu.:0.01509   1st Qu.:0.007638  
##  Median :0.006380   Median :0.020450   Median :0.02589   Median :0.010930  
##  Mean   :0.007041   Mean   :0.025478   Mean   :0.03189   Mean   :0.011796  
##  3rd Qu.:0.008146   3rd Qu.:0.032450   3rd Qu.:0.04205   3rd Qu.:0.014710  
##  Max.   :0.031130   Max.   :0.135400   Max.   :0.39600   Max.   :0.052790  
##   symmetry_SE       fractal_dimension_SE  radius_worst   texture_worst  
##  Min.   :0.007882   Min.   :0.0008948    Min.   : 7.93   Min.   :12.02  
##  1st Qu.:0.015160   1st Qu.:0.0022480    1st Qu.:13.01   1st Qu.:21.08  
##  Median :0.018730   Median :0.0031870    Median :14.97   Median :25.41  
##  Mean   :0.020542   Mean   :0.0037949    Mean   :16.27   Mean   :25.68  
##  3rd Qu.:0.023480   3rd Qu.:0.0045580    3rd Qu.:18.79   3rd Qu.:29.72  
##  Max.   :0.078950   Max.   :0.0298400    Max.   :36.04   Max.   :49.54  
##  perimeter_worst    area_worst     smoothness_worst  compactness_worst
##  Min.   : 50.41   Min.   : 185.2   Min.   :0.07117   Min.   :0.02729  
##  1st Qu.: 84.11   1st Qu.: 515.3   1st Qu.:0.11660   1st Qu.:0.14720  
##  Median : 97.66   Median : 686.5   Median :0.13130   Median :0.21190  
##  Mean   :107.26   Mean   : 880.6   Mean   :0.13237   Mean   :0.25427  
##  3rd Qu.:125.40   3rd Qu.:1084.0   3rd Qu.:0.14600   3rd Qu.:0.33910  
##  Max.   :251.20   Max.   :4254.0   Max.   :0.22260   Max.   :1.05800  
##  concavity_worst  concave_points_worst symmetry_worst   fractal_dimension_worst
##  Min.   :0.0000   Min.   :0.00000      Min.   :0.1565   Min.   :0.05504        
##  1st Qu.:0.1145   1st Qu.:0.06493      1st Qu.:0.2504   1st Qu.:0.07146        
##  Median :0.2267   Median :0.09993      Median :0.2822   Median :0.08004        
##  Mean   :0.2722   Mean   :0.11461      Mean   :0.2901   Mean   :0.08395        
##  3rd Qu.:0.3829   3rd Qu.:0.16140      3rd Qu.:0.3179   3rd Qu.:0.09208        
##  Max.   :1.2520   Max.   :0.29100      Max.   :0.6638   Max.   :0.20750

Enfin, la matrice de corrélation nous permet d’observer les corrélations entre nos variables.

Les valeurs élevées et basses dans le contexte de la corrélation indiquent la force et la direction de la relation linéaire entre deux variables. Voici ce que signifient les valeurs élevées et basses de corrélation :

  • Valeurs élevées de corrélation positive : Une valeur élevée de corrélation positive (proche de +1) indique une relation linéaire forte et positive entre les deux variables. Cela signifie que lorsque la valeur d’une variable augmente, la valeur de l’autre variable augmente également.

  • Valeurs élevées de corrélation négative : Une valeur élevée de corrélation négative (proche de -1) indique une relation linéaire forte et négative entre les deux variables. Cela signifie que lorsque la valeur d’une variable augmente, la valeur de l’autre variable diminue.

  • Valeurs proches de zéro ou faibles de corrélation : Des valeurs proches de zéro ou faibles de corrélation (proches de 0) indiquent une faible relation linéaire entre les variables. Cela suggère qu’il y a peu ou pas de lien linéaire entre les variables étudiées. Une corrélation faible signifie que les valeurs des variables ne varient pas de manière linéairement prévisible.

data_noDiagnosis <- subset(clean_data, select = -Diagnosis)

cor_matrix <- cor(data_noDiagnosis)

# Afficher la matrice de corrélation
cor_matrix_melted <- melt(cor_matrix)
ggplot(data = cor_matrix_melted, aes(x = Var1, y = Var2, fill = value)) +
  geom_tile() +
  scale_fill_gradient(low = "blue", high = "red") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) + 
  labs(title = "Matrice de corrélation",
      x = "Variable 1", y = "Variable 2",
      caption = "Basé sur le dataset wdbc.data")

Question n°2

1 - Analyse descriptive du jeu de donnée par clustering K-means

Pour réaliser cette analyse descriptive, nous allons réaliser une analyse par clustering en utilisant la méthode des k plus proches voisins.

Dans un premier temps, il est alors nécessaire de charger et de nettoyer le jeu de données en renommant les variables et en éliminant les données manquantes. Il est aussi nécessaire de renommer les différentes variables présentes dans le dataset. Ainsi, les variables se terminant par _mean réfèrent à la moyenne de celle-ci, les variables se terminant par _SE indiquent la Mean Squared Error et celle terminant par _worst indiquent la pire évaluation.

km_dataset <- data %>% 
  drop_na()

Le paramétrage de la seed ci-dessous permet d’obtenir une reproductibilité dans les résultats obtenus lors des entraînements de modèles.

set.seed(123)

Par choix, nous allons choisir de nous concentrer sur les variables terminant par _mean afin d’obtenir une certaine constance dans les résultats et leurs interprétabilité.

Dans le but de déterminer le nombre optimal de clusters, nous allons utiliser l’Elbow method qui consiste à tracer la somme des carrés des distances intracluster (WCSS) en fonction du nombre de clusters et à rechercher le point où la courbe forme un “coude” ou un changement de direction brusque.

Ainsi dans la courbe obtenue ci-dessous, on peut observer que la cassure a lieu pour 2 clusters. Voici donc notre nombre optimal de clusters.

# Fancy K-Means
fviz_nbclust(scale(km_dataset[,3:12]), kmeans, nstart=100, method = "wss") + 
  geom_vline(xintercept = 2, linetype = 1)

La méthode utilisée ici est que le modèle va créer une dataset clone de celui initial et va y ajouter une variable supplémentaire nommée ‘Cluster’ et pour chaque ligne y indiquer dans quels clusters elle se trouve.

kmeans_basic <- kmeans(km_dataset[,3:12], centers = 2)
kmeans_basic_table <- data.frame(kmeans_basic$size, kmeans_basic$centers)
kmeans_basic_df <- data.frame(Cluster = kmeans_basic$cluster, km_dataset)

kable(kmeans_basic_df[1:6, 1:7], 
      format = "latex",
      booktabs = T)

On peut alors représenter les deux clusters créés puis y indiquer en leurs seins s’il s’agit du diagnostic bénin (B) ou alors malin (M).

Dans ce graphique, on peut alors observer que le cluster 2 est quasiment totalement constitué de patients dont la tumeur a été diagnostiquée comme maligne tandis que pour le cluster 1, on peut remarquer qu’il y a une nette disparité dans la composition du cluster.

# Example ggplot
ggplot(data = kmeans_basic_df, aes(x = Cluster)) +
  geom_bar(aes(fill = Diagnosis)) +
  ggtitle("Count of Clusters by Diagnosis") +
  theme(plot.title = element_text(hjust = 0.5)) +
  scale_fill_brewer(palette = "Set1")

On peut aussi observer ci-dessous la représentation graphique des deux clusters obtenus.

fviz_cluster(kmeans_basic, data = scale(km_dataset[,3:12]), geom = c("point"),ellipse.type = "euclid")

Dans cette seconde partie de la génération du modèle de clustering par k-mean, nous allons essayer d’améliorer le modèle que nous avions précédemment obtenu. Pour cela, nous allons augmenter le nombre d’essais de génération du clustering en passant à 100 le nombre de positions aléatoire de départ du K.

# Fancy kmeans
set.seed(123)
kmeans_fancy <- kmeans(scale(km_dataset[,3:12]), 2, nstart = 100)

kmeans_fancy_df <- data.frame(Cluster = kmeans_fancy$cluster, km_dataset)

# plot the clusters
fviz_cluster(kmeans_fancy, data = scale(km_dataset[,3:12]), geom = c("point"),ellipse.type = "euclid")

On observe pour ce nouveau modèle qu’un des clusters reste majoritairement composé de patients dont la tumeur est maligne tandis que pour le second cluster, la proportion de patient dont la tumeur est maligne diminue comparé au précédent modèle. On peut alors en conclure que le second modèle est plus précis pour partitionner les deux classes de patients.

ggplot(data = kmeans_fancy_df, aes(x = Cluster)) +
  geom_bar(aes(fill = Diagnosis)) +
  ggtitle("Count of Clusters by Diagnosis") +
  theme(plot.title = element_text(hjust = 0.5)) + 
  scale_fill_brewer(palette = "Set1")

Enfin, dans le tableau ci-dessous, nous réalisons une étude statistique de la composition des clusters.

outCtl <- tableby(Cluster ~ Diagnosis + radius_mean + texture_mean + 
                    perimeter_mean + area_mean + smoothness_mean + 
                    compactness_mean + concavity_mean + concave_points_mean + 
                    symmetry_mean + fractal_dimension_mean, 
                  data=kmeans_fancy_df,
                  control=tableby.control(total=T, cat.simplify=F, 
                  numeric.stats = c("Nmiss", "meansd", "range"),digits=1))

summary(outCtl, text=F)
1 (N=169) 2 (N=400) Total (N=569) p value
Diagnosis < 0.001
   B 6 (3.6%) 351 (87.8%) 357 (62.7%)
   M 163 (96.4%) 49 (12.2%) 212 (37.3%)
radius_mean < 0.001
   Mean (SD) 18.1 (3.2) 12.5 (2.0) 14.1 (3.5)
   Range 9.3 - 28.1 7.0 - 18.8 7.0 - 28.1
texture_mean < 0.001
   Mean (SD) 21.5 (4.1) 18.4 (4.0) 19.3 (4.3)
   Range 10.4 - 39.3 9.7 - 33.8 9.7 - 39.3
perimeter_mean < 0.001
   Mean (SD) 119.9 (21.8) 80.2 (13.0) 92.0 (24.3)
   Range 61.5 - 188.5 43.8 - 120.9 43.8 - 188.5
area_mean < 0.001
   Mean (SD) 1045.6 (377.1) 489.8 (156.4) 654.9 (351.9)
   Range 248.7 - 2501.0 143.5 - 1102.0 143.5 - 2501.0
smoothness_mean < 0.001
   Mean (SD) 0.1 (0.0) 0.1 (0.0) 0.1 (0.0)
   Range 0.1 - 0.2 0.1 - 0.1 0.1 - 0.2
compactness_mean < 0.001
   Mean (SD) 0.2 (0.1) 0.1 (0.0) 0.1 (0.1)
   Range 0.1 - 0.3 0.0 - 0.2 0.0 - 0.3
concavity_mean < 0.001
   Mean (SD) 0.2 (0.1) 0.0 (0.0) 0.1 (0.1)
   Range 0.1 - 0.4 0.0 - 0.3 0.0 - 0.4
concave_points_mean < 0.001
   Mean (SD) 0.1 (0.0) 0.0 (0.0) 0.0 (0.0)
   Range 0.1 - 0.2 0.0 - 0.1 0.0 - 0.2
symmetry_mean < 0.001
   Mean (SD) 0.2 (0.0) 0.2 (0.0) 0.2 (0.0)
   Range 0.1 - 0.3 0.1 - 0.3 0.1 - 0.3
fractal_dimension_mean 0.006
   Mean (SD) 0.1 (0.0) 0.1 (0.0) 0.1 (0.0)
   Range 0.1 - 0.1 0.0 - 0.1 0.0 - 0.1

2 - Analyse descriptive du jeu de donnée par clustering Classification ascendante hiérarchique

wdbc <- read_csv("wdbc.data", 
                 col_names = c("ID number",
                               "Diagnosis",
                               "radius_mean",
                               "texture_mean",
                               "perimeter_mean",
                               "area_mean","smoothness_mean",
                               "compactness_mean",
                               "concavity_mean",
                               "concave_points_mean",
                               "symmetry_mean",
                               "fractal_dimension_mean",
                               "radius_SE","texture_SE",
                               "perimeter_SE","area_SE",
                               "smoothness_SE",
                               "compactness_SE",
                               "concavity_SE",
                               "concave_points_SE",
                               "symmetry_SE",
                               "fractal_dimension_SE",
                               "radius_worst",
                               "texture_worst",
                               "perimeter_worst",
                               "area_worst",
                               "smoothness_worst",
                               "compactness_worst",
                               "concavity_worst",
                               "concave_points_worst",
                               "symmetry_worst",
                               "fractal_dimension_worst"))
## Rows: 569 Columns: 32
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr  (1): Diagnosis
## dbl (31): ID number, radius_mean, texture_mean, perimeter_mean, area_mean, s...
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

Nous sélectionnons les variables qui nous interessent, ici tous les variables _mean, et faisons une standardisation. Nous faisons ensuite un calcul de la matrice de distances entre les individus en utilisant la méthode de calcul euclidienne.

# Sélection des variables et standardisation
myvars <- wdbc[,c("radius_mean", "texture_mean", "perimeter_mean","area_mean","smoothness_mean","compactness_mean","concavity_mean","concave_points_mean","symmetry_mean","fractal_dimension_mean")]
myvars <- scale(myvars)

# Calcul de la matrice de distances
mydist <- dist(myvars, method = "euclidean")
head(mydist)
## [1] 7.082678 4.791658 5.245540 5.210302 4.610234 6.436641

Nous effectuons maintenant la classification ascendante hiérarchique en utilisant la méthode de Ward.Nous obtenons ainsi un dendrogramme représentant la classification obtenue.

# Classification ascendante hiérarchique
myhclust <- hclust(mydist, method = "ward.D2")

# Visualisation du dendrogramme
plot(myhclust, labels = FALSE)

Nous allons utiliser des visualisations pour interpréter les résultats de l’analyse de clustering et prendre des décisions concernant le nombre de classes à retenir. Nous pouvons voir que nous observons qu’il est possible de définir 2 ou 3 classes suite à la classification.

inertie <- sort(myhclust$height, decreasing = TRUE)
plot(inertie[1:20], type = "s", xlab = "Nombre de classes", ylab = "Inertie")
points(c(2, 3), inertie[c(2, 3)], col = c("green3", "red3"), cex = 2, lwd = 3)

plot(myhclust, labels = FALSE, main = "Partition en 2 ou 3 classes", xlab = "", ylab = "", sub = "", axes = FALSE, hang = -1)
rect.hclust(myhclust, 2, border = "green3")
rect.hclust(myhclust, 3, border = "red3")

fviz_dend(myhclust, k = 2, show_labels = FALSE, rect = TRUE)

fviz_dend(myhclust, k = 3, show_labels = FALSE, rect = TRUE)

Nous utilisons une fonction nous permettant de déterminer la meilleure coupe du dendrogramme.Nous obtenons comme résultat que le nombre de classes optimal est 3.

best.cutree(myhclust)
## [1] 3
best.cutree(myhclust, graph = TRUE, xlab = "Nombre de classes", ylab = "Inertie relative")

## [1] 3
typo <- cutree(myhclust, 3)
freq(typo)
## 
## 
## **Frequency table**   
## 
## Class:      integer (numeric)  
## Length:     569  
## Available:  569 (100%, NA: 0 = 0%)  
## Unique:     3  
##   
## Mean:       2.41  
## SD:         0.82 (CV: 0.34, MAD: 0)  
## Five-Num:   1 | 2 | 3 | 3 | 3 (IQR: 1, CQV: 0.2)  
## Outliers:   0 (0%)
## 
## 
## |   |  Item|  Count|  Percent|  Cum. Count|  Cum. Percent|
## |:--|-----:|------:|--------:|-----------:|-------------:|
## |1  |     3|    352|   61.86%|         352|        61.86%|
## |2  |     1|    120|   21.09%|         472|        82.95%|
## |3  |     2|     97|   17.05%|         569|       100.00%|

Nous prenons donc comme valeur k= 3 et ajoutons une variable supplémentaire nommée ‘Cluster’ et pour chaque ligne y indiquer dans quels clusters elle se trouve.

# Détermination du nombre de groupes à former
mycut <- cutree(myhclust, k = 3)

# Attribution des individus aux groupes correspondants
wdbc$Cluster <- mycut

hc.cut <- hcut(myvars, k= 3, hc_method = "complete")
fviz_cluster(hc.cut, ellipse.type = "convex")

Nous utilisons l’indice de Rand ajusté, pour évaluer objectivement la qualité de notre clustering en le comparant aux véritables classes des données. Cela nous permet de mesurer à quel point les groupes obtenus correspondent aux structures réelles des données.Nous obtenons Une valeur de 0,47, qui indique une concordance relativement faible entre les partitions du clustering et les étiquettes de classes.

rst <- adjustedRandIndex(mycut, wdbc$Diagnosis) 
rst
## [1] 0.4698196

Question 3

Nous allons ensuite développer différents modèles de diagnostic et en évaluer leurs performances. Trois approches vont être utilisées : une méthode par Arbre de décision, une par Forêts aléatoires et une par Ensemble Learning.

1 - Méthode par Arbre de décision

Pour cette méthode par Arbre de décision, nous allons commencer par charger une dataset clone des données que nous souhaitons analyser. Nous allons ensuite partitionner ce dataset en deux parties : une qui servira de base de données d’entrainement du modèle, et une qui nous permettra d’évaluer le modèle obtenu précédemment.

library(tidyverse)
library(FactoMineR)
library(factoextra)
library(rpart)
library(rpart.plot)
library(caret)

dt_dataset <- clean_data

nb_lignes <- floor((nrow(dt_dataset)*0.75)) #Nombre de lignes de l’échantillon d’apprentissage : 75% du dataset
dt_dataset <- dt_dataset[sample(nrow(dt_dataset)), ] #Ajout de numéros de lignes
dt_dataset.train <- dt_dataset[1:nb_lignes, ] #Echantillon d’apprentissage
dt_dataset.test <- dt_dataset[(nb_lignes+1):nrow(dt_dataset), ] #Echantillon de test

Voici ci-dessous les résultats du modèle entraîné sur le dataset d’entraînement. Cet arbre de décision est volumineux et va donc avoir besoin d’un élagage afin de réduire sa complexité. Pour cela, nous allons faire appel à la formule du coût de complexité. Il s’agit d’un paramètre qui permet de contrôler la taille maximale de l’arbre de décision, c’est-à-dire le nombre maximal de nœuds ou de feuilles dans l’arbre.

En général, un arbre de décision plus complexe peut mieux s’adapter aux données d’entraînement, mais il est également plus susceptible de surapprendre (overfitting) et de mal généraliser aux nouvelles données. Par conséquent, le coût de complexité est souvent utilisé pour éviter le surapprentissage en régularisant le modèle et en limitant sa complexité.

set.seed(12)
#Construction de l’arbre
dataset.Tree <- rpart(Diagnosis ~ ., 
                      data = dt_dataset.train,
                      method = "class", 
                      control = rpart.control(minsplit = 5, cp=0))

#Affichage du résultat
rpart.plot(dataset.Tree)

Pour bien élaguer notre arbre de décision, nous allons chercher le coût de complexité (cp) pour lequel le taux de mauvais classement (xerror) est la plus faible.

#On cherche à minimiser l’erreur pour définir le niveau d’élagage
#plotcp(dataset.Tree)
printcp(dataset.Tree)
## 
## Classification tree:
## rpart(formula = Diagnosis ~ ., data = dt_dataset.train, method = "class", 
##     control = rpart.control(minsplit = 5, cp = 0))
## 
## Variables actually used in tree construction:
## [1] area_mean           concave_points_mean concavity_mean     
## [4] perimeter_mean      radius_mean         smoothness_mean    
## [7] texture_mean       
## 
## Root node error: 166/426 = 0.38967
## 
## n= 426 
## 
##          CP nsplit rel error  xerror     xstd
## 1 0.7951807      0  1.000000 1.00000 0.060636
## 2 0.0361446      1  0.204819 0.22289 0.035016
## 3 0.0301205      2  0.168675 0.25301 0.037066
## 4 0.0180723      3  0.138554 0.24096 0.036267
## 5 0.0090361      5  0.102410 0.18072 0.031812
## 6 0.0060241      7  0.084337 0.17470 0.031317
## 7 0.0000000     15  0.036145 0.18675 0.032297

Le coût de complexité optimal pour ce modèle va s’afficher sous ce paragraphe. Ce paramètre va ensuite être utilisé pour élaguer l’arbre obtenu précédemment.

print(dataset.Tree$cptable[which.min(dataset.Tree$cptable[,4]),1])
## [1] 0.006024096

Voici donc ci-dessous le résultat de l’élagage de l’arbre de décision. Ce nouvel arbre est plus court et donc, plus généraliste et aura par conséquence moins tendance à overfitter.

set.seed(12)
#Elagage de l’arbre avec le cp optimal
dataset.Tree_Opt <- prune(dataset.Tree,
                          cp = dataset.Tree$cptable[which.min(dataset.Tree$cptable[,4]),1])

#Représentation graphique de l’arbre optimal
rpart.plot(dataset.Tree_Opt)

Enfin, nous avons entrainé le modèle obtenu sur le dataset de test que nous avions précédemment créé. Ensuite, nous avons réalisé plusieurs tests statistiques sur les prédictions qu’il a pu faire.

Les résultats de l’arbre de décision montrent une performance globalement élevée, avec une précision (accuracy) de 91,61%. On peut être satisfait de la capacité du modèle à discriminer entre les classes, avec une sensibilité de 84% pour la classe positive (M) et une spécificité de 95,7% pour la classe négative (B). Le coefficient Kappa de 0,812 indique un accord significatif entre les prédictions du modèle et les valeurs réelles. Ces résultats me donnent confiance dans la compétence du modèle à effectuer des prédictions précises.

#Prédiction du modèle sur les données de test
dataset.test_Predict<-predict(dataset.Tree_Opt,newdata=dt_dataset.test, type= "class")

dt_dataset.test$Diagnosis <- factor(dt_dataset.test$Diagnosis, levels = c("B", "M"))

#Création d'un tableau de confusion
confusionMatrix(dt_dataset.test$Diagnosis, dataset.test_Predict, positive = "M")
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction  B  M
##          B 89  8
##          M  4 42
##                                          
##                Accuracy : 0.9161         
##                  95% CI : (0.858, 0.9559)
##     No Information Rate : 0.6503         
##     P-Value [Acc > NIR] : 1.266e-13      
##                                          
##                   Kappa : 0.812          
##                                          
##  Mcnemar's Test P-Value : 0.3865         
##                                          
##             Sensitivity : 0.8400         
##             Specificity : 0.9570         
##          Pos Pred Value : 0.9130         
##          Neg Pred Value : 0.9175         
##              Prevalence : 0.3497         
##          Detection Rate : 0.2937         
##    Detection Prevalence : 0.3217         
##       Balanced Accuracy : 0.8985         
##                                          
##        'Positive' Class : M              
## 

2 - Méthode par Forets aléatoires

Pour cette méthode par Forêts aléatoires (Random forests), il est nécessaire de partitionner notre dataset initial en deux sections : une d’entraînement et une de test.

# Diviser les données en ensembles d'apprentissage et de test
set.seed(123) # pour la reproductibilité des résultats

train_index <- sample(nrow(rf_dataset), 0.7 * nrow(rf_dataset))
train_data <- rf_dataset[train_index, ]
test_data <- rf_dataset[-train_index, ]

Nous allons ensuite entrainer le modèle de Random forests.

# Entraîner le modèle de forêt aléatoire
rf_model <- randomForest(Diagnosis ~ ., data = train_data, ntree = 100, mtry = 2, na.action = na.omit)

# Afficher les résultats du modèle
print(rf_model)
## 
## Call:
##  randomForest(formula = Diagnosis ~ ., data = train_data, ntree = 100,      mtry = 2, na.action = na.omit) 
##                Type of random forest: classification
##                      Number of trees: 100
## No. of variables tried at each split: 2
## 
##         OOB estimate of  error rate: 6.03%
## Confusion matrix:
##     B   M class.error
## B 249  10  0.03861004
## M  14 125  0.10071942

Puis faire en sorte d’afficher les variables que le modèle considère comme importantes et indiquer par un score si elles sont plus ou moins importantes.

Les variables les plus importantes sont celles qui ont les valeurs les plus élevées de “MeanDecreaseGini”. Dans notre cas, les variables les plus importantes sont “concave_points_mean” avec une valeur de 38.963054, suivie par “area_mean” avec 27.354739 et “perimeter_mean” avec 25.170804.

Les variables ayant des valeurs relativement faibles de “MeanDecreaseGini” sont considérées comme moins importantes pour la prédiction dans ce modèle. Ici, les variables “symmetry_mean” et “fractal_dimension_mean” ont les valeurs les plus faibles avec 3.806719 et 4.201104 respectivement et présentent donc l’importance la plus faible.

# Calculer l'importance des variables
var_importance <- importance(rf_model)

# Afficher les variables les plus importantes
print(var_importance)
##                        MeanDecreaseGini
## radius_mean                   24.858775
## texture_mean                  11.107298
## perimeter_mean                25.170804
## area_mean                     27.354739
## smoothness_mean                6.419145
## compactness_mean              11.717715
## concavity_mean                26.848889
## concave_points_mean           38.963054
## symmetry_mean                  3.806719
## fractal_dimension_mean         4.201104

Enfin nous allons soumettre notre modèle au dataset de test afin qu’il puissent réaliser ses prédictions. Ses résultats seront analysés grace à différents tests statistiques.

En résumé, notre modèle Random Forest semble présenter de bons résultats avec une précision globale de 91,81%. Il démontre une sensibilité élevée (94,03%) et une bonne spécificité (90,38%). Le coefficient Kappa de 0,8309 indique un accord entre les prédictions du modèle et les étiquettes réelles.

# Évaluer la performance du modèle sur les données de test
rf_predictions <- predict(rf_model, test_data)
confusionMatrix(test_data$Diagnosis, rf_predictions, positive = "M")
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction  B  M
##          B 94  4
##          M 10 63
##                                           
##                Accuracy : 0.9181          
##                  95% CI : (0.8664, 0.9545)
##     No Information Rate : 0.6082          
##     P-Value [Acc > NIR] : <2e-16          
##                                           
##                   Kappa : 0.8309          
##                                           
##  Mcnemar's Test P-Value : 0.1814          
##                                           
##             Sensitivity : 0.9403          
##             Specificity : 0.9038          
##          Pos Pred Value : 0.8630          
##          Neg Pred Value : 0.9592          
##              Prevalence : 0.3918          
##          Detection Rate : 0.3684          
##    Detection Prevalence : 0.4269          
##       Balanced Accuracy : 0.9221          
##                                           
##        'Positive' Class : M               
## 

3 - Méthode par Ensemble Learning

Pour cette méthode par Ensemble Learning, nous allons utiliser 3 techniques différentes afin d’agréger les différents algorithmes qui seront utilisés. Nous exploiterons dans un premier temps un algorithme de Boosting, puis de Bagging et enfin de Stacking.

Les algorithmes par Boosting font en sorte que construire plusieurs modèles qui vont fixer les erreurs de prédictions du précédent modèle dans la chaine. Ceux par Bagging vont construire différents modèles sur différentes partitions du dataset initial. Enfin ceux par Stacking construisent différents modèles et un modèle de supervision qui va apprendre comment combiner ces modèles primaires.

Ainsi ci-dessous, nous allons agréger un algorithme nommé C5.0 et un algorithme appelé Stochastic Gradient Boosting (GBM). Les résultats affichés ci-dessous indiquent que le GBM est légèrement supérieur au C5.0 avec une précision (Accuracy) de 95.07% contre 95.01% et un Kappa (score permettant d’évaluer la performance d’un modèle) de 89.41% contre 89.32%.

# Example of Boosting Algorithms
control <- trainControl(method="repeatedcv", number=10, repeats=3)
seed <- 7
metric <- "Accuracy"

# C5.0
set.seed(seed)
fit.c50 <- train(Diagnosis~., data=clean_data, method="C5.0", metric=metric, trControl=control)

# Stochastic Gradient Boosting
set.seed(seed)
fit.gbm <- train(Diagnosis~., data=clean_data, method="gbm", metric=metric, trControl=control, verbose=FALSE)

# summarize results
boosting_results <- resamples(list(c5.0=fit.c50, gbm=fit.gbm))
summary(boosting_results)
## 
## Call:
## summary.resamples(object = boosting_results)
## 
## Models: c5.0, gbm 
## Number of resamples: 30 
## 
## Accuracy 
##           Min.   1st Qu.    Median      Mean   3rd Qu. Max. NA's
## c5.0 0.9107143 0.9174877 0.9473684 0.9501217 0.9824561    1    0
## gbm  0.8928571 0.9298246 0.9482759 0.9507476 0.9778352    1    0
## 
## Kappa 
##           Min.   1st Qu.    Median      Mean   3rd Qu. Max. NA's
## c5.0 0.8076923 0.8231128 0.8880157 0.8932379 0.9619238    1    0
## gbm  0.7714286 0.8480159 0.8891720 0.8941705 0.9524623    1    0
dotplot(boosting_results)

Ensuite, dans le cadre des algorithmes de Bagging, nous allons utiliser deux algorithmes différents : le Bagged CART et les Forêts aléatoires (Random forests). Les résultats obtenus indiquent que le modèle basé sur le Random forests est supérieur au Bagged CART avec une précision de 94.31% contre 94.01% et un Kappa de 87.85% contre 87.21%.

# Example of Bagging algorithms
control <- trainControl(method="repeatedcv", number=10, repeats=3)
seed <- 7
metric <- "Accuracy"

# Bagged CART
set.seed(seed)
fit.treebag <- train(Diagnosis~., data=clean_data, method="treebag", metric=metric, trControl=control)

# Random Forest
set.seed(seed)
fit.rf <- train(Diagnosis~., data=clean_data, method="rf", metric=metric, trControl=control)

# summarize results
bagging_results <- resamples(list(treebag=fit.treebag, rf=fit.rf))
summary(bagging_results)
## 
## Call:
## summary.resamples(object = bagging_results)
## 
## Models: treebag, rf 
## Number of resamples: 30 
## 
## Accuracy 
##             Min.   1st Qu.    Median      Mean   3rd Qu. Max. NA's
## treebag 0.862069 0.9163534 0.9473684 0.9401679 0.9649123    1    0
## rf      0.862069 0.9285714 0.9385965 0.9431333 0.9653660    1    0
## 
## Kappa 
##              Min.   1st Qu.    Median      Mean   3rd Qu. Max. NA's
## treebag 0.7121588 0.8211847 0.8857715 0.8721974 0.9246779    1    0
## rf      0.7121588 0.8453999 0.8700779 0.8785620 0.9265933    1    0
dotplot(bagging_results)

Pour la méthode par Stacking, nous utilisons 5 algorithmes : Linear Discriminate Analysis (LDA), Classification and Regression Trees (CART), la Régression logistique, les K plus proches voisins et Support Vector Machine with a Radial Basis Kernel Function (SVM).

Les résultats indiquent que le SVM produit le modèle le plus précis avec une précision de 95.02% et un Kappa de 89.22%.

# Example of Stacking algorithms
# create submodels
control <- trainControl(method="repeatedcv", number=10, repeats=3, savePredictions=TRUE, classProbs=TRUE)
algorithmList <- c('lda', 'rpart', 'glm', 'knn', 'svmRadial')
set.seed(seed)
models <- caretList(Diagnosis~., data=clean_data, trControl=control, methodList=algorithmList)
results <- resamples(models)
summary(results)
## 
## Call:
## summary.resamples(object = results)
## 
## Models: lda, rpart, glm, knn, svmRadial 
## Number of resamples: 30 
## 
## Accuracy 
##                Min.   1st Qu.    Median      Mean   3rd Qu.      Max. NA's
## lda       0.8571429 0.9122807 0.9304295 0.9344115 0.9647556 1.0000000    0
## rpart     0.8421053 0.8947368 0.9130369 0.9151114 0.9425800 0.9649123    0
## glm       0.8596491 0.9122807 0.9468985 0.9337654 0.9482759 0.9824561    0
## knn       0.7719298 0.8750000 0.8947368 0.8904431 0.9134150 0.9649123    0
## svmRadial 0.8448276 0.9339756 0.9562808 0.9502229 0.9778352 1.0000000    0
## 
## Kappa 
##                Min.   1st Qu.    Median      Mean   3rd Qu.      Max. NA's
## lda       0.6767677 0.8078828 0.8471607 0.8560612 0.9228902 1.0000000    0
## rpart     0.6614786 0.7742824 0.8126460 0.8189212 0.8756117 0.9260700    0
## glm       0.6984127 0.8123184 0.8857715 0.8574269 0.8891720 0.9626719    0
## knn       0.4618736 0.7231262 0.7668468 0.7576957 0.8148049 0.9246032    0
## svmRadial 0.6675159 0.8557692 0.9057510 0.8922843 0.9526714 1.0000000    0
dotplot(results)

On peut observer, avant de stacker les modèles, que LDA présente de fortes corrélations avec GLM (0.8 de corrélation avec un seuil significatif à 0.75) et avec SVM (0.77 de corrélations).

# correlation between results
modelCor(results)
##                 lda     rpart       glm       knn svmRadial
## lda       1.0000000 0.6352583 0.8028110 0.4247722 0.7764634
## rpart     0.6352583 1.0000000 0.5923717 0.4254711 0.6501977
## glm       0.8028110 0.5923717 1.0000000 0.5633917 0.6297564
## knn       0.4247722 0.4254711 0.5633917 1.0000000 0.4808792
## svmRadial 0.7764634 0.6501977 0.6297564 0.4808792 1.0000000
splom(results)

Étant donné les trop fortes corrélations avec ces trois algorithmes, nous allons donc exclure LDA afin d’éviter de fausser notre modèle par Stacking. On peut alors observer que par ce Stacking par GLM, notre précision a diminué de 95.02% à 94.49% et le Kappa a de même diminué de 89.22% à 88.15%.

La conclusion de cette technique de Stacking par GLM est donc que notre modèle par SVM apportait de meilleures performances sans Stacking.

# stack using glm
new_algorithmList <- c('glm', 'rpart', 'knn', 'svmRadial')
new_models <- caretList(Diagnosis~., data=clean_data, trControl=control, methodList=new_algorithmList)


stackControl <- trainControl(method="repeatedcv", number=10, repeats=3, savePredictions=TRUE, classProbs=TRUE)
set.seed(seed)
stack.glm <- caretStack(new_models, method="glm", metric="Accuracy", trControl=stackControl)
print(stack.glm)
## A glm ensemble of 4 base models: glm, rpart, knn, svmRadial
## 
## Ensemble results:
## Generalized Linear Model 
## 
## 1707 samples
##    4 predictor
##    2 classes: 'B', 'M' 
## 
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 3 times) 
## Summary of sample sizes: 1537, 1536, 1536, 1536, 1535, 1537, ... 
## Resampling results:
## 
##   Accuracy   Kappa    
##   0.9449211  0.8815106

Tandis que pour le Stacking par Random Forests, notre précision augmente en passant à 96.21% et le Kappa augmente aussi pour atteindre 91.82%.

On peut donc affirmer que le Stacking par Random Forests apporte les meilleures performances de modèles par Ensemble Learning.

# stack using random forest
set.seed(seed)
stack.rf <- caretStack(new_models, method="rf", metric="Accuracy", trControl=stackControl)
print(stack.rf)
## A rf ensemble of 4 base models: glm, rpart, knn, svmRadial
## 
## Ensemble results:
## Random Forest 
## 
## 1707 samples
##    4 predictor
##    2 classes: 'B', 'M' 
## 
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 3 times) 
## Summary of sample sizes: 1537, 1536, 1536, 1536, 1535, 1537, ... 
## Resampling results across tuning parameters:
## 
##   mtry  Accuracy   Kappa    
##   2     0.9621016  0.9182071
##   3     0.9619044  0.9178726
##   4     0.9599528  0.9136868
## 
## Accuracy was used to select the optimal model using the largest value.
## The final value used for the model was mtry = 2.

Partie II

Nous avons choisi comme de notre choix un dataset sur le diabète et nous avons fais le choix de choisir une approche supervisée d’arbre de décision. Dataset : https://www.kaggle.com/datasets/iammustafatz/diabetes-prediction-dataset?resource=download&fbclid=IwAR1F9jDfOzNJTqTne1SHU1kka85rcS9atS6BihGSZFTxHp80T2t9Egps5YU

Nous commencons par nettoyer notre dataset et vérifier que nos variables sont bien définies sous la bonne catégorie de variables : ici factoriser 6 de nos variables.

diabetes_prediction_dataset <- read_csv("diabetes_prediction_dataset.csv")

diabetes_prediction_dataset$gender[diabetes_prediction_dataset$gender == "Other"] <- NA
diabetes_prediction_dataset$smoking_history[diabetes_prediction_dataset$smoking_history == "No Info"] <- NA
glimpse(diabetes_prediction_dataset)
## Rows: 100,000
## Columns: 9
## $ gender              <chr> "Female", "Female", "Male", "Female", "Male", "Fem…
## $ age                 <dbl> 80, 54, 28, 36, 76, 20, 44, 79, 42, 32, 53, 54, 78…
## $ hypertension        <dbl> 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
## $ heart_disease       <dbl> 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
## $ smoking_history     <chr> "never", NA, "never", "current", "current", "never…
## $ bmi                 <dbl> 25.19, 27.32, 27.32, 23.45, 20.14, 27.32, 19.31, 2…
## $ HbA1c_level         <dbl> 6.6, 6.6, 5.7, 5.0, 4.8, 6.6, 6.5, 5.7, 4.8, 5.0, …
## $ blood_glucose_level <dbl> 140, 80, 158, 155, 155, 85, 200, 85, 145, 100, 85,…
## $ diabetes            <dbl> 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
diabetes_prediction_dataset$gender <- as.factor(diabetes_prediction_dataset$gender)
diabetes_prediction_dataset$hypertension <- as.factor(diabetes_prediction_dataset$hypertension)
diabetes_prediction_dataset$heart_disease <- as.factor(diabetes_prediction_dataset$heart_disease)
diabetes_prediction_dataset$heart_disease <- as.factor(diabetes_prediction_dataset$heart_disease)
diabetes_prediction_dataset$smoking_history <- as.factor(diabetes_prediction_dataset$smoking_history)
diabetes_prediction_dataset$diabetes <- as.factor(diabetes_prediction_dataset$diabetes)

summary(diabetes_prediction_dataset)
##     gender           age        hypertension heart_disease    smoking_history 
##  Female:58552   Min.   : 0.08   0:92515      0:96058       current    : 9286  
##  Male  :41430   1st Qu.:24.00   1: 7485      1: 3942       ever       : 4004  
##  NA's  :   18   Median :43.00                              former     : 9352  
##                 Mean   :41.89                              never      :35095  
##                 3rd Qu.:60.00                              not current: 6447  
##                 Max.   :80.00                              NA's       :35816  
##       bmi         HbA1c_level    blood_glucose_level diabetes 
##  Min.   :10.01   Min.   :3.500   Min.   : 80.0       0:91500  
##  1st Qu.:23.63   1st Qu.:4.800   1st Qu.:100.0       1: 8500  
##  Median :27.32   Median :5.800   Median :140.0                
##  Mean   :27.32   Mean   :5.528   Mean   :138.1                
##  3rd Qu.:29.58   3rd Qu.:6.200   3rd Qu.:159.0                
##  Max.   :95.69   Max.   :9.000   Max.   :300.0

Pour cette méthode par Arbre de décision, nous allons partionner ce dataset en deux parties : une qui servira de base de données d’entrainement du modèle, et une qui nous permettra d’évaluer le modèle obtenu précédemment.

#Création d’un dataset d’apprentissage et d’un dataset de validation
nb_lignes <- floor((nrow(diabetes_prediction_dataset)*0.75)) #Nombre de lignes de l’échantillon d’apprentissage : 75% du dataset
diabetes_prediction_dataset <- diabetes_prediction_dataset[sample(nrow(diabetes_prediction_dataset)), ] #Ajout de numéros de lignes
diabetes.train <- diabetes_prediction_dataset[1:nb_lignes, ] #Echantillon d’apprentissage
diabetes.test <- diabetes_prediction_dataset[(nb_lignes+1):nrow(diabetes_prediction_dataset), ] #Echantillon de test

Voici ci-dessous les résultats du modèle entraîné sur le dataset d’entraînement. Cet arbre de décision est volumineux et va donc avoir besoin d’un élagage afin de réduire sa complexité. Pour cela, nous allons faire appel à la formule du coût de complexité. Il s’agit d’un paramètre qui permet de contrôler la taille maximale de l’arbre de décision, c’est-à-dire le nombre maximal de nœuds ou de feuilles dans l’arbre.

En général, un arbre de décision plus complexe peut mieux s’adapter aux données d’entraînement, mais il est également plus susceptible de surapprendre (overfitting) et de mal généraliser aux nouvelles données. Par conséquent, le coût de complexité est souvent utilisé pour éviter le surapprentissage en régularisant le modèle et en limitant sa complexité.

set.seed(12)
#Construction de l’arbre
diabetes.Tree <- rpart(diabetes~.,
                       data=diabetes.train,
                       method= "class",
                       control=rpart.control(minsplit=8,cp=0))

#Affichage du résultat
rpart.plot(diabetes.Tree)

Pour bien élaguer notre arbre de décision, nous allons chercher le coût de complexité (cp) pour lequel le taux de mauvais classement (xerror) est la plus faible.

#On cherche à minimiser l’erreur pour définir le niveau d’élagage
#plotcp(diabetes.Tree)
printcp(diabetes.Tree)
## 
## Classification tree:
## rpart(formula = diabetes ~ ., data = diabetes.train, method = "class", 
##     control = rpart.control(minsplit = 8, cp = 0))
## 
## Variables actually used in tree construction:
## [1] age                 blood_glucose_level bmi                
## [4] gender              HbA1c_level         heart_disease      
## [7] hypertension        smoking_history    
## 
## Root node error: 6339/75000 = 0.08452
## 
## n= 75000 
## 
##            CP nsplit rel error  xerror      xstd
## 1  4.5780e-01      0   1.00000 1.00000 0.0120175
## 2  2.1155e-01      1   0.54220 0.54220 0.0090341
## 3  5.2585e-04      2   0.33065 0.33065 0.0071207
## 4  4.7326e-04     11   0.32418 0.33065 0.0071207
## 5  3.5495e-04     14   0.32276 0.33412 0.0071568
## 6  3.1551e-04     20   0.32056 0.33602 0.0071765
## 7  2.6292e-04     29   0.31772 0.33854 0.0072026
## 8  2.5635e-04     32   0.31693 0.34422 0.0072610
## 9  2.5241e-04     58   0.30904 0.34501 0.0072690
## 10 2.3663e-04     71   0.30525 0.34690 0.0072884
## 11 2.2536e-04     87   0.30068 0.34800 0.0072996
## 12 2.1034e-04     95   0.29879 0.35006 0.0073204
## 13 1.9719e-04     98   0.29815 0.35274 0.0073476
## 14 1.8930e-04    102   0.29737 0.35321 0.0073523
## 15 1.6902e-04    121   0.29342 0.35400 0.0073603
## 16 1.5775e-04    135   0.29106 0.36441 0.0074643
## 17 1.3146e-04    229   0.27307 0.37388 0.0075575
## 18 1.2620e-04    238   0.27181 0.38113 0.0076281
## 19 1.1832e-04    245   0.27071 0.38271 0.0076434
## 20 1.1268e-04    278   0.26613 0.38997 0.0077130
## 21 1.0517e-04    384   0.25051 0.39012 0.0077145
## 22 9.8596e-05    414   0.24688 0.39170 0.0077296
## 23 9.4652e-05    422   0.24610 0.39218 0.0077341
## 24 7.8877e-05    429   0.24499 0.40921 0.0078944
## 25 6.7609e-05    535   0.23553 0.41347 0.0079339
## 26 6.3101e-05    544   0.23490 0.41805 0.0079761
## 27 5.2585e-05    572   0.23300 0.42735 0.0080611
## 28 4.5072e-05    650   0.22843 0.43130 0.0080968
## 29 3.9438e-05    671   0.22748 0.44360 0.0082071
## 30 3.5056e-05    719   0.22527 0.44518 0.0082211
## 31 3.1551e-05    748   0.22417 0.44755 0.0082421
## 32 2.6292e-05    838   0.22117 0.45275 0.0082880
## 33 2.2536e-05    868   0.22038 0.45638 0.0083198
## 34 1.9719e-05    875   0.22022 0.45701 0.0083253
## 35 1.7528e-05    907   0.21959 0.45749 0.0083294
## 36 1.5775e-05    916   0.21944 0.45843 0.0083377
## 37 0.0000e+00    926   0.21928 0.45875 0.0083404

Le coût de complexité optimal pour ce modèle va s’afficher sous ce paragraphe. Ce paramètre va ensuite être utilisé pour élaguer l’arbre obtenu précédemment.

print(diabetes.Tree$cptable[which.min(diabetes.Tree$cptable[,4]),1])
## [1] 0.0005258453

Voici donc ci-dessous le résultat de l’élagage de l’arbre de décision. Ce nouvel arbre est plus court et donc, plus généraliste et aura par conséquence moins tendance à overfitter.

set.seed(12)
#Elagage de l’arbre avec le cp optimal
diabetes.Tree_Opt <- prune(diabetes.Tree,cp=diabetes.Tree$cptable[which.min(diabetes.Tree$cptable[,4]),1])

#Représentation graphique de l’arbre optimal
rpart.plot(diabetes.Tree_Opt)

Enfin, nous avons entrainé le modèle obtenu sur le dataset de test que nous avions précédemment créé. Ensuite, nous avons réalisé plusieurs tests statistiques sur les prédictions qu’il a pu faire.

Les résultats de l’arbre de décision montrent une performance globalement élevée, avec une précision (accuracy) de 97.22%. On peut être satisfait de la capacité du modèle à discriminer entre les classes, avec une sensibilité de 100% pour la classe positive (1) et une spécificité de 97.04% pour la classe négative (0). Le coefficient Kappa de 0.793 indique un accord significatif entre les prédictions du modèle et les valeurs réelles. Ces résultats me donnent confiance dans la compétence du modèle à effectuer des prédictions précises.

#Prédiction du modèle sur les données de test
diabetes.test_Predict<-predict(diabetes.Tree_Opt,newdata=diabetes.test, type= "class")

#Création d'un tableau de confusion
confusionMatrix(diabetes.test$diabetes, diabetes.test_Predict, positive = "1")
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction     0     1
##          0 22839     0
##          1   717  1444
##                                           
##                Accuracy : 0.9713          
##                  95% CI : (0.9692, 0.9734)
##     No Information Rate : 0.9422          
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.7863          
##                                           
##  Mcnemar's Test P-Value : < 2.2e-16       
##                                           
##             Sensitivity : 1.00000         
##             Specificity : 0.96956         
##          Pos Pred Value : 0.66821         
##          Neg Pred Value : 1.00000         
##              Prevalence : 0.05776         
##          Detection Rate : 0.05776         
##    Detection Prevalence : 0.08644         
##       Balanced Accuracy : 0.98478         
##                                           
##        'Positive' Class : 1               
##